home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / emacssrc.zip / EMACSSRC.TAR / emacs-19.17 / lisp / diary.el < prev    next >
Lisp/Scheme  |  1993-07-23  |  91KB  |  1,922 lines
  1. ;;; diary.el --- diary functions.
  2.  
  3. ;; Copyright (C) 1989, 1990, 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12. ;; accepts responsibility to anyone for the consequences of using it
  13. ;; or for whether it serves any particular purpose or works at all,
  14. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15. ;; License for full details.
  16.  
  17. ;; Everyone is granted permission to copy, modify and redistribute
  18. ;; GNU Emacs, but only under the conditions described in the
  19. ;; GNU Emacs General Public License.   A copy of this license is
  20. ;; supposed to have been given to you along with GNU Emacs so you
  21. ;; can know your rights and responsibilities.  It should be in a
  22. ;; file named COPYING.  Among other things, the copyright notice
  23. ;; and this notice must be preserved on all copies.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; This collection of functions implements the diary features as described
  28. ;; in calendar.el.
  29.  
  30. ;; Comments, corrections, and improvements should be sent to
  31. ;;  Edward M. Reingold               Department of Computer Science
  32. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  33. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  34. ;;                                   Urbana, Illinois 61801
  35.  
  36. ;;; Code:
  37.  
  38. (require 'calendar)
  39.  
  40. ;;;###autoload
  41. (defun diary (&optional arg)
  42.   "Generate the diary window for ARG days starting with the current date.
  43. If no argument is provided, the number of days of diary entries is governed
  44. by the variable `number-of-diary-entries'.  This function is suitable for
  45. execution in a .emacs file."
  46.   (interactive "P")
  47.   (let ((d-file (substitute-in-file-name diary-file))
  48.         (date (calendar-current-date)))
  49.     (if (and d-file (file-exists-p d-file))
  50.         (if (file-readable-p d-file)
  51.             (list-diary-entries
  52.              date
  53.              (cond
  54.               (arg (prefix-numeric-value arg))
  55.               ((vectorp number-of-diary-entries)
  56.                (aref number-of-diary-entries (calendar-day-of-week date)))
  57.               (t number-of-diary-entries)))
  58.         (error "Your diary file is not readable!"))
  59.       (error "You don't have a diary file!"))))
  60.  
  61. (defun view-diary-entries (arg)
  62.   "Prepare and display a buffer with diary entries.
  63. Searches the file diary-file for entries that match ARG days starting with
  64. the date indicated by the cursor position in the displayed three-month
  65. calendar."
  66.   (interactive "p")
  67.   (let ((d-file (substitute-in-file-name diary-file)))
  68.     (if (and d-file (file-exists-p d-file))
  69.         (if (file-readable-p d-file)
  70.             (list-diary-entries (or (calendar-cursor-to-date)
  71.                                     (error "Cursor is not on a date!"))
  72.                                 arg)
  73.           (error "Your diary file is not readable!"))
  74.       (error "You don't have a diary file!"))))
  75.  
  76. (autoload 'check-calendar-holidays "holidays"
  77.   "Check the list of holidays for any that occur on DATE.
  78. The value returned is a list of strings of relevant holiday descriptions.
  79. The holidays are those in the list calendar-holidays."
  80.   t)
  81.  
  82.  
  83. (autoload 'calendar-holiday-list "holidays"
  84.   "Form the list of holidays that occur on dates in the calendar window.
  85. The holidays are those in the list calendar-holidays."
  86.   t)
  87.  
  88. (autoload 'diary-french-date "cal-french"
  89.   "French calendar equivalent of date diary entry."
  90.   t)
  91.  
  92. (autoload 'diary-mayan-date "cal-mayan"
  93.   "Mayan calendar equivalent of date diary entry."
  94.   t)
  95.  
  96. (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
  97.  
  98. (autoload 'diary-sunrise-sunset "solar"
  99.   "Local time of sunrise and sunset as a diary entry."
  100.   t)
  101.  
  102. (autoload 'diary-sabbath-candles "solar"
  103.   "Local time of candle lighting diary entry--applies if date is a Friday.
  104. No diary entry if there is no sunset on that date."
  105.   t)
  106.  
  107. (defvar diary-syntax-table
  108.   (standard-syntax-table)
  109.   "The syntax table used when parsing dates in the diary file.
  110. It is the standard syntax table used in Fundamental mode, but with the
  111. syntax of `*' changed to be a word constituent.")
  112.  
  113. (modify-syntax-entry ?* "w" diary-syntax-table)
  114.  
  115. (defun list-diary-entries (date number)
  116.   "Create and display a buffer containing the relevant lines in diary-file.
  117. The arguments are DATE and NUMBER; the entries selected are those
  118. for NUMBER days starting with date DATE.  The other entries are hidden
  119. using selective display.
  120.  
  121. Returns a list of all relevant diary entries found, if any, in order by date.
  122. The list entries have the form ((month day year) string).  If the variable
  123. `diary-list-include-blanks' is t, this list includes a dummy diary entry
  124. \(consisting of the empty string) for a date with no diary entries.
  125.  
  126. After the list is prepared, the hooks `nongregorian-diary-listing-hook',
  127. `list-diary-entries-hook', and `diary-display-hook' are run.  These hooks
  128. have the following distinct roles:
  129.  
  130.     `nongregorian-diary-listing-hook' can cull dates from the diary
  131.         and each included file.  Usually used for Hebrew or Islamic
  132.         diary entries in files.  Applied to *each* file.
  133.  
  134.     `list-diary-entries-hook' adds or manipulates diary entries from
  135.         external sources.  Used, for example, to include diary entries
  136.         from other files or to sort the diary entries.  Invoked *once* only.
  137.  
  138.     `diary-display-hook' does the actual display of information.  Could be
  139.         used also for an appointment notification function."
  140.  
  141.   (if (< 0 number)
  142.       (let* ((original-date date);; save for possible use in the hooks
  143.              (old-diary-syntax-table)
  144.              (diary-entries-list)
  145.              (date-string (calendar-date-string date))
  146.              (d-file (substitute-in-file-name diary-file)))
  147.         (message "Preparing diary...")
  148.         (save-excursion
  149.           (let ((diary-buffer (get-file-buffer d-file)))
  150.             (set-buffer (if diary-buffer
  151.                             diary-buffer
  152.                          (find-file-noselect d-file t))))
  153.           (setq selective-display t)
  154.           (setq selective-display-ellipses nil)
  155.           (setq old-diary-syntax-table (syntax-table))
  156.           (set-syntax-table diary-syntax-table)
  157.           (unwind-protect
  158.             (let ((buffer-read-only nil)
  159.                   (diary-modified (buffer-modified-p))
  160.                   (mark (regexp-quote diary-nonmarking-symbol)))
  161.               (goto-char (1- (point-max)))
  162.               (if (not (looking-at "\^M\\|\n"))
  163.                   (progn
  164.                     (forward-char 1)
  165.                     (insert-string "\^M")))
  166.               (goto-char (point-min))
  167.               (if (not (looking-at "\^M\\|\n"))
  168.                   (insert-string "\^M"))
  169.               (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
  170.               (calendar-for-loop i from 1 to number do
  171.                  (let ((d diary-date-forms)
  172.                        (month (extract-calendar-month date))
  173.                        (day (extract-calendar-day date))
  174.                        (year (extract-calendar-year date))
  175.                        (entry-found (list-sexp-diary-entries date)))
  176.                    (while d
  177.                      (let*
  178.                           ((date-form (if (equal (car (car d)) 'backup)
  179.                                           (cdr (car d))
  180.                                         (car d)))
  181.                           (backup (equal (car (car d)) 'backup))
  182.                           (dayname
  183.                            (concat
  184.                             (calendar-day-name date) "\\|"
  185.                             (substring (calendar-day-name date) 0 3) ".?"))
  186.                           (monthname
  187.                            (concat
  188.                             "\\*\\|"
  189.                             (calendar-month-name month) "\\|"
  190.                             (substring (calendar-month-name month) 0 3) ".?"))
  191.                           (month (concat "\\*\\|0*" (int-to-string month)))
  192.                           (day (concat "\\*\\|0*" (int-to-string day)))
  193.                           (year
  194.                            (concat
  195.                             "\\*\\|0*" (int-to-string year)
  196.                             (if abbreviated-calendar-year
  197.                                 (concat "\\|" (int-to-string (% year 100)))
  198.                               "")))
  199.                           (regexp
  200.                            (concat
  201.                             "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
  202.                             (mapconcat 'eval date-form "\\)\\(")
  203.                             "\\)"))
  204.                           (case-fold-search t))
  205.                        (goto-char (point-min))
  206.                        (while (re-search-forward regexp nil t)
  207.                          (if backup (re-search-backward "\\<" nil t))
  208.                          (if (and (or (char-equal (preceding-char) ?\^M)
  209.                                       (char-equal (preceding-char) ?\n))
  210.                                   (not (looking-at " \\|\^I")))
  211.                              ;;  Diary entry that consists only of date.
  212.                              (backward-char 1)
  213.                            ;; Found a nonempty diary entry--make it visible and
  214.                            ;; add it to the list.
  215.                            (setq entry-found t)
  216.                            (let ((entry-start (point))
  217.                                  (date-start))
  218.                              (re-search-backward "\^M\\|\n\\|\\`")
  219.                              (setq date-start (point))
  220.                              (re-search-forward "\^M\\|\n" nil t 2)
  221.                              (while (looking-at " \\|\^I")
  222.                                (re-search-forward "\^M\\|\n" nil t))
  223.                              (backward-char 1)
  224.                              (subst-char-in-region date-start
  225.                                 (point) ?\^M ?\n t)
  226.                              (add-to-diary-list
  227.                                date (buffer-substring entry-start (point)))))))
  228.                      (setq d (cdr d)))
  229.                    (or entry-found
  230.                        (not diary-list-include-blanks)
  231.                        (setq diary-entries-list 
  232.                              (append diary-entries-list
  233.                                      (list (list date "")))))
  234.                    (setq date
  235.                          (calendar-gregorian-from-absolute
  236.                            (1+ (calendar-absolute-from-gregorian date))))
  237.                    (setq entry-found nil)))
  238.               (set-buffer-modified-p diary-modified))
  239.           (set-syntax-table old-diary-syntax-table))
  240.         (goto-char (point-min))
  241.         (run-hooks 'nongregorian-diary-listing-hook
  242.                    'list-diary-entries-hook
  243.                    'diary-display-hook)
  244.         diary-entries-list))))
  245.  
  246. (defun include-other-diary-files ()
  247.   "Include the diary entries from other diary files with those of diary-file.
  248. This function is suitable for use just before fancy-diary-display as the
  249. list-diary-entries-hook; it enables you to use shared diary files together
  250. with your own.  The files included are specified in the diary-file by lines of
  251. the form
  252.         #include \"filename\"
  253. This is recursive; that is, #include directives in diary files thus included
  254. are obeyed.  You can change the \"#include\" to some other string by
  255. changing the variable `diary-include-string'."
  256.   (goto-char (point-min))
  257.   (while (re-search-forward
  258.           (concat
  259.            "\\(\\`\\|\^M\\|\n\\)"
  260.            (regexp-quote diary-include-string)
  261.            " \"\\([^\"]*\\)\"")
  262.           nil t)
  263.     (let ((diary-file (substitute-in-file-name
  264.                        (buffer-substring (match-beginning 2) (match-end 2))))
  265.           (diary-list-include-blanks nil)
  266.           (list-diary-entries-hook 'include-other-diary-files)
  267.           (diary-display-hook nil))
  268.       (if (file-exists-p diary-file)
  269.           (if (file-readable-p diary-file)
  270.               (unwind-protect
  271.                   (setq diary-entries-list
  272.                         (append diary-entries-list
  273.                                 (list-diary-entries original-date number)))
  274.                 (kill-buffer (get-file-buffer diary-file)))
  275.             (beep)
  276.             (message "Can't read included diary file %s" diary-file)
  277.             (sleep-for 2))
  278.         (beep)
  279.         (message "Can't find included diary file %s" diary-file)
  280.         (sleep-for 2))))
  281.     (goto-char (point-min)))
  282.  
  283. (defun simple-diary-display ()
  284.   "Display the diary buffer if there are any relevant entries or holidays."
  285.   (let* ((holiday-list (if holidays-in-diary-buffer
  286.                            (check-calendar-holidays original-date)))
  287.          (msg (format "No diary entries for %s %s"
  288.                       (concat date-string (if holiday-list ":" ""))
  289.                       (mapconcat 'identity holiday-list "; "))))
  290.     (if (or (not diary-entries-list)
  291.             (and (not (cdr diary-entries-list))
  292.                  (string-equal (car (cdr (car diary-entries-list))) "")))
  293.         (if (<= (length msg) (frame-width))
  294.             (message msg)
  295.           (set-buffer (get-buffer-create holiday-buffer))
  296.           (setq buffer-read-only nil)
  297.           (calendar-set-mode-line date-string)
  298.           (erase-buffer)
  299.           (insert (mapconcat 'identity holiday-list "\n"))
  300.           (goto-char (point-min))
  301.           (set-buffer-modified-p nil)
  302.           (setq buffer-read-only t)
  303.           (display-buffer holiday-buffer)
  304.           (message  "No diary entries for %s" date-string))
  305.       (calendar-set-mode-line
  306.        (concat "Diary for " date-string
  307.                (if holiday-list ": " "")
  308.                (mapconcat 'identity holiday-list "; ")))
  309.       (display-buffer (get-file-buffer d-file))
  310.       (message "Preparing diary...done"))))
  311.  
  312. (defun fancy-diary-display ()
  313.   "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
  314. This function is provided for optional use as the `list-diary-entries-hook'."
  315.   (if (or (not diary-entries-list)
  316.           (and (not (cdr diary-entries-list))
  317.                (string-equal (car (cdr (car diary-entries-list))) "")))
  318.       (let* ((holiday-list (if holidays-in-diary-buffer
  319.                                (check-calendar-holidays original-date)))
  320.              (msg (format "No diary entries for %s %s"
  321.                           (concat date-string (if holiday-list ":" ""))
  322.                           (mapconcat 'identity holiday-list "; "))))
  323.         (if (<= (length msg) (frame-width))
  324.             (message msg)
  325.           (set-buffer (get-buffer-create holiday-buffer))
  326.           (setq buffer-read-only nil)
  327.           (calendar-set-mode-line date-string)
  328.           (erase-buffer)
  329.           (insert (mapconcat 'identity holiday-list "\n"))
  330.           (goto-char (point-min))
  331.           (set-buffer-modified-p nil)
  332.           (setq buffer-read-only t)
  333.           (display-buffer holiday-buffer)
  334.           (message  "No diary entries for %s" date-string)))
  335.     (save-excursion;; Turn off selective-display in the diary file's buffer.
  336.       (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
  337.       (let ((diary-modified (buffer-modified-p)))
  338.         (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  339.         (setq selective-display nil)
  340.         (kill-local-variable 'mode-line-format)
  341.         (set-buffer-modified-p diary-modified)))
  342.     (save-excursion;; Prepare the fancy diary buffer.
  343.       (set-buffer (get-buffer-create fancy-diary-buffer))
  344.       (setq buffer-read-only nil)
  345.       (make-local-variable 'mode-line-format)
  346.       (calendar-set-mode-line "Diary Entries")
  347.       (erase-buffer)
  348.       (let ((entry-list diary-entries-list)
  349.             (holiday-list)
  350.             (holiday-list-last-month 1)
  351.             (holiday-list-last-year 1)
  352.             (date (list 0 0 0)))
  353.         (while entry-list
  354.           (if (not (calendar-date-equal date (car (car entry-list))))
  355.               (progn
  356.                 (setq date (car (car entry-list)))
  357.                 (and holidays-in-diary-buffer
  358.                      (calendar-date-compare
  359.                       (list (list holiday-list-last-month
  360.                                   (calendar-last-day-of-month
  361.                                    holiday-list-last-month
  362.                                    holiday-list-last-year)
  363.                                   holiday-list-last-year))
  364.                       (list date))
  365.                      ;; We need to get the holidays for the next 3 months.
  366.                      (setq holiday-list-last-month
  367.                            (extract-calendar-month date))
  368.                      (setq holiday-list-last-year
  369.                            (extract-calendar-year date))
  370.                      (increment-calendar-month
  371.                       holiday-list-last-month holiday-list-last-year 1)
  372.                      (setq holiday-list
  373.                            (let ((displayed-month holiday-list-last-month)
  374.                                  (displayed-year holiday-list-last-year))
  375.                              (calendar-holiday-list)))
  376.                      (increment-calendar-month
  377.                       holiday-list-last-month holiday-list-last-year 1))
  378.                 (let* ((date-string (calendar-date-string date))
  379.                        (date-holiday-list
  380.                         (let ((h holiday-list)
  381.                               (d))
  382.                           ;; Make a list of all holidays for date.
  383.                           (while h
  384.                             (if (calendar-date-equal date (car (car h)))
  385.                                 (setq d (append d (cdr (car h)))))
  386.                             (setq h (cdr h)))
  387.                           d)))
  388.                   (insert (if (= (point) (point-min)) "" ?\n) date-string)
  389.                   (if date-holiday-list (insert ":  "))
  390.                   (let ((l (current-column)))
  391.                     (insert (mapconcat 'identity date-holiday-list
  392.                                        (concat "\n" (make-string l ? )))))
  393.                   (let ((l (current-column)))
  394.                     (insert ?\n (make-string l ?=) ?\n)))))
  395.           (if (< 0 (length (car (cdr (car entry-list)))))
  396.               (insert (car (cdr (car entry-list))) ?\n))
  397.           (setq entry-list (cdr entry-list))))
  398.       (set-buffer-modified-p nil)
  399.       (goto-char (point-min))
  400.       (setq buffer-read-only t)
  401.       (display-buffer fancy-diary-buffer)
  402.       (message "Preparing diary...done"))))
  403.  
  404. (defun print-diary-entries ()
  405.   "Print a hard copy of the diary display.
  406.  
  407. If the simple diary display is being used, prepare a temp buffer with the
  408. visible lines of the diary buffer, add a heading line composed from the mode
  409. line, print the temp buffer, and destroy it.
  410.  
  411. If the fancy diary display is being used, just print the buffer.
  412.  
  413. The hooks given by the variable `print-diary-entries-hook' are called to do
  414. the actual printing."
  415.   (interactive)
  416.   (if (bufferp (get-buffer fancy-diary-buffer))
  417.       (save-excursion
  418.         (set-buffer (get-buffer fancy-diary-buffer))
  419.         (run-hooks 'print-diary-entries-hook))
  420.     (let ((diary-buffer
  421.            (get-file-buffer (substitute-in-file-name diary-file))))
  422.       (if diary-buffer
  423.           (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
  424.                 (heading))
  425.             (save-excursion
  426.               (set-buffer diary-buffer)
  427.               (setq heading
  428.                     (if (not (stringp mode-line-format))
  429.                         "All Diary Entries"
  430.                       (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
  431.                       (substring mode-line-format
  432.                                  (match-beginning 1) (match-end 1))))
  433.               (copy-to-buffer temp-buffer (point-min) (point-max))
  434.               (set-buffer temp-buffer)
  435.               (while (re-search-forward "\^M.*$" nil t)
  436.                 (replace-match ""))
  437.               (goto-char (point-min))
  438.               (insert heading "\n"
  439.                       (make-string (length heading) ?=) "\n")
  440.               (run-hooks 'print-diary-entries-hook)
  441.               (kill-buffer temp-buffer)))
  442.         (error "You don't have a diary buffer!")))))
  443.  
  444. (defun show-all-diary-entries ()
  445.   "Show all of the diary entries in the diary-file.
  446. This function gets rid of the selective display of the diary-file so that
  447. all entries, not just some, are visible.  If there is no diary buffer, one
  448. is created."
  449.   (interactive)
  450.   (let ((d-file (substitute-in-file-name diary-file)))
  451.     (if (and d-file (file-exists-p d-file))
  452.         (if (file-readable-p d-file)
  453.             (save-excursion
  454.               (let ((diary-buffer (get-file-buffer d-file)))
  455.                 (set-buffer (if diary-buffer
  456.                                 diary-buffer
  457.                               (find-file-noselect d-file t)))
  458.                 (let ((buffer-read-only nil)
  459.                       (diary-modified (buffer-modified-p)))
  460.                   (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  461.                   (setq selective-display nil)
  462.                   (make-local-variable 'mode-line-format)
  463.                   (setq mode-line-format default-mode-line-format)
  464.                   (display-buffer (current-buffer))
  465.                   (set-buffer-modified-p diary-modified))))
  466.           (error "Your diary file is not readable!"))
  467.       (error "You don't have a diary file!"))))
  468.  
  469. (defun diary-name-pattern (string-array &optional fullname)
  470.   "Convert an STRING-ARRAY, an array of strings to a pattern.
  471. The pattern will match any of the strings, either entirely or abbreviated
  472. to three characters.  An abbreviated form will match with or without a period;
  473. If the optional FULLNAME is t, abbreviations will not match, just the full
  474. name."
  475.   (let ((pattern ""))
  476.     (calendar-for-loop i from 0 to (1- (length string-array)) do
  477.       (setq pattern
  478.             (concat
  479.              pattern
  480.              (if (string-equal pattern "") "" "\\|")
  481.              (aref string-array i)
  482.              (if fullname
  483.                  ""
  484.                (concat
  485.                 "\\|"
  486.                 (substring (aref string-array i) 0 3) ".?")))))
  487.     pattern))
  488.  
  489. (defun mark-diary-entries ()
  490.   "Mark days in the calendar window that have diary entries.
  491. Each entry in diary-file visible in the calendar window is marked.  After the
  492. entries are marked, the hooks `nongregorian-diary-marking-hook' and
  493. `mark-diary-entries-hook' are run."
  494.   (interactive)
  495.   (setq mark-diary-entries-in-calendar t)
  496.   (let ((d-file (substitute-in-file-name diary-file)))
  497.     (if (and d-file (file-exists-p d-file))
  498.         (if (file-readable-p d-file)
  499.             (save-excursion
  500.               (message "Marking diary entries...")
  501.               (set-buffer (find-file-noselect d-file t))
  502.               (let ((d diary-date-forms)
  503.                     (old-diary-syntax-table))
  504.                 (setq old-diary-syntax-table (syntax-table))
  505.                 (set-syntax-table diary-syntax-table)
  506.                 (while d
  507.                   (let*
  508.                       ((date-form (if (equal (car (car d)) 'backup)
  509.                                       (cdr (car d))
  510.                                     (car d)));; ignore 'backup directive
  511.                        (dayname (diary-name-pattern calendar-day-name-array))
  512.                        (monthname
  513.                         (concat
  514.                          (diary-name-pattern calendar-month-name-array)
  515.                          "\\|\\*"))
  516.                        (month "[0-9]+\\|\\*")
  517.                        (day "[0-9]+\\|\\*")
  518.                        (year "[0-9]+\\|\\*")
  519.                        (l (length date-form))
  520.                        (d-name-pos (- l (length (memq 'dayname date-form))))
  521.                        (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  522.                        (m-name-pos (- l (length (memq 'monthname date-form))))
  523.                        (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  524.                        (d-pos (- l (length (memq 'day date-form))))
  525.                        (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  526.                        (m-pos (- l (length (memq 'month date-form))))
  527.                        (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  528.                        (y-pos (- l (length (memq 'year date-form))))
  529.                        (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  530.                        (regexp
  531.                         (concat
  532.                          "\\(\\`\\|\^M\\|\n\\)\\("
  533.                          (mapconcat 'eval date-form "\\)\\(")
  534.                          "\\)"))
  535.                        (case-fold-search t))
  536.                     (goto-char (point-min))
  537.                     (while (re-search-forward regexp nil t)
  538.                       (let* ((dd-name
  539.                               (if d-name-pos
  540.                                   (buffer-substring
  541.                                    (match-beginning d-name-pos)
  542.                                    (match-end d-name-pos))))
  543.                              (mm-name
  544.                               (if m-name-pos
  545.                                   (buffer-substring
  546.                                    (match-beginning m-name-pos)
  547.                                    (match-end m-name-pos))))
  548.                              (mm (string-to-int
  549.                                   (if m-pos
  550.                                       (buffer-substring
  551.                                        (match-beginning m-pos)
  552.                                        (match-end m-pos))
  553.                                     "")))
  554.                              (dd (string-to-int
  555.                                   (if d-pos
  556.                                       (buffer-substring
  557.                                        (match-beginning d-pos)
  558.                                        (match-end d-pos))
  559.                                     "")))
  560.                              (y-str (if y-pos
  561.                                         (buffer-substring
  562.                                          (match-beginning y-pos)
  563.                                          (match-end y-pos))))
  564.                              (yy (if (not y-str)
  565.                                      0
  566.                                    (if (and (= (length y-str) 2)
  567.                                             abbreviated-calendar-year)
  568.                                        (let* ((current-y
  569.                                                (extract-calendar-year
  570.                                                 (calendar-current-date)))
  571.                                               (y (+ (string-to-int y-str)
  572.                                                     (* 100
  573.                                                        (/ current-y 100)))))
  574.                                          (if (> (- y current-y) 50)
  575.                                              (- y 100)
  576.                                            (if (> (- current-y y) 50)
  577.                                                (+ y 100)
  578.                                              y)))
  579.                                      (string-to-int y-str)))))
  580.                         (if dd-name
  581.                             (mark-calendar-days-named
  582.                              (cdr (assoc (capitalize (substring dd-name 0 3))
  583.                                          (calendar-make-alist
  584.                                           calendar-day-name-array
  585.                                           0
  586.                                           '(lambda (x) (substring x 0 3))))))
  587.                           (if mm-name
  588.                               (if (string-equal mm-name "*")
  589.                                   (setq mm 0)
  590.                                 (setq mm
  591.                                       (cdr (assoc
  592.                                             (capitalize
  593.                                              (substring mm-name 0 3))
  594.                                             (calendar-make-alist
  595.                                              calendar-month-name-array
  596.                                              1
  597.                                              '(lambda (x) (substring x 0 3)))
  598.                                             )))))
  599.                           (mark-calendar-date-pattern mm dd yy))))
  600.                     (setq d (cdr d))))
  601.                 (mark-sexp-diary-entries)
  602.                 (run-hooks 'nongregorian-diary-marking-hook
  603.                            'mark-diary-entries-hook)
  604.                 (set-syntax-table old-diary-syntax-table)
  605.                 (message "Marking diary entries...done")))
  606.           (error "Your diary file is not readable!"))
  607.       (error "You don't have a diary file!"))))
  608.  
  609. (defun mark-sexp-diary-entries ()
  610.   "Mark days in the calendar window that have sexp diary entries.
  611. Each entry in diary-file (or included files) visible in the calendar window
  612. is marked.  See the documentation for the function `list-sexp-diary-entries'."
  613.   (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
  614.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
  615.          (m)
  616.          (y)
  617.          (first-date)
  618.          (last-date))
  619.     (save-excursion
  620.       (set-buffer calendar-buffer)
  621.       (setq m displayed-month)
  622.       (setq y displayed-year))
  623.     (increment-calendar-month m y -1)
  624.     (setq first-date
  625.           (calendar-absolute-from-gregorian (list m 1 y)))
  626.     (increment-calendar-month m y 2)
  627.     (setq last-date
  628.           (calendar-absolute-from-gregorian
  629.            (list m (calendar-last-day-of-month m y) y)))
  630.     (goto-char (point-min))
  631.     (while (re-search-forward s-entry nil t)
  632.       (backward-char 1)
  633.       (let ((sexp-start (point))
  634.             (sexp)
  635.             (entry)
  636.             (entry-start)
  637.             (line-start))
  638.         (forward-sexp)
  639.         (setq sexp (buffer-substring sexp-start (point)))
  640.         (save-excursion
  641.           (re-search-backward "\^M\\|\n\\|\\`")
  642.           (setq line-start (point)))
  643.         (forward-char 1)
  644.         (if (and (or (char-equal (preceding-char) ?\^M)
  645.                      (char-equal (preceding-char) ?\n))
  646.                  (not (looking-at " \\|\^I")))
  647.             (progn;; Diary entry consists only of the sexp
  648.               (backward-char 1)
  649.               (setq entry ""))
  650.           (setq entry-start (point))
  651.           (re-search-forward "\^M\\|\n" nil t)
  652.           (while (looking-at " \\|\^I")
  653.             (re-search-forward "\^M\\|\n" nil t))
  654.           (backward-char 1)
  655.           (setq entry (buffer-substring entry-start (point)))
  656.           (while (string-match "[\^M]" entry)
  657.             (aset entry (match-beginning 0) ?\n )))
  658.         (calendar-for-loop date from first-date to last-date do
  659.           (if (diary-sexp-entry sexp entry
  660.                                 (calendar-gregorian-from-absolute date))
  661.               (mark-visible-calendar-date
  662.                (calendar-gregorian-from-absolute date))))))))
  663.  
  664. (defun mark-included-diary-files ()
  665.   "Mark the diary entries from other diary files with those of diary-file.
  666. This function is suitable for use as the mark-diary-entries-hook; it enables
  667. you to use shared diary files together with your own.  The files included are
  668. specified in the diary-file by lines of the form
  669.         #include \"filename\"
  670. This is recursive; that is, #include directives in diary files thus included
  671. are obeyed.  You can change the \"#include\" to some other string by
  672. changing the variable `diary-include-string'."
  673.   (goto-char (point-min))
  674.   (while (re-search-forward
  675.           (concat
  676.            "\\(\\`\\|\^M\\|\n\\)"
  677.            (regexp-quote diary-include-string)
  678.            " \"\\([^\"]*\\)\"")
  679.           nil t)
  680.     (let ((diary-file (substitute-in-file-name
  681.                        (buffer-substring (match-beginning 2) (match-end 2))))
  682.           (mark-diary-entries-hook 'mark-included-diary-files))
  683.       (if (file-exists-p diary-file)
  684.           (if (file-readable-p diary-file)
  685.               (progn
  686.                 (mark-diary-entries)
  687.                 (kill-buffer (get-file-buffer diary-file)))
  688.             (beep)
  689.             (message "Can't read included diary file %s" diary-file)
  690.             (sleep-for 2))
  691.         (beep)
  692.         (message "Can't find included diary file %s" diary-file)
  693.         (sleep-for 2))))
  694.   (goto-char (point-min)))
  695.  
  696. (defun mark-calendar-days-named (dayname)
  697.   "Mark all dates in the calendar window that are day DAYNAME of the week.
  698. 0 means all Sundays, 1 means all Mondays, and so on."
  699.   (save-excursion
  700.     (set-buffer calendar-buffer)
  701.     (let ((prev-month displayed-month)
  702.           (prev-year displayed-year)
  703.           (succ-month displayed-month)
  704.           (succ-year displayed-year)
  705.           (last-day)
  706.           (day))
  707.       (increment-calendar-month succ-month succ-year 1)
  708.       (increment-calendar-month prev-month prev-year -1)
  709.       (setq day (calendar-absolute-from-gregorian
  710.                  (calendar-nth-named-day 1 dayname prev-month prev-year)))
  711.       (setq last-day (calendar-absolute-from-gregorian
  712.                  (calendar-nth-named-day -1 dayname succ-month succ-year)))
  713.       (while (<= day last-day)
  714.         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
  715.         (setq day (+ day 7))))))
  716.  
  717. (defun mark-calendar-date-pattern (month day year)
  718.   "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  719. A value of 0 in any position is a wild-card."
  720.   (save-excursion
  721.     (set-buffer calendar-buffer)
  722.     (let ((m displayed-month)
  723.           (y displayed-year))
  724.       (increment-calendar-month m y -1)
  725.       (calendar-for-loop i from 0 to 2 do
  726.           (mark-calendar-month m y month day year)
  727.           (increment-calendar-month m y 1)))))
  728.  
  729. (defun mark-calendar-month (month year p-month p-day p-year)
  730.   "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  731. A value of 0 in any position of the pattern is a wild-card."
  732.   (if (or (and (= month p-month)
  733.                (or (= p-year 0) (= year p-year)))
  734.           (and (= p-month 0)
  735.                (or (= p-year 0) (= year p-year))))
  736.       (if (= p-day 0)
  737.           (calendar-for-loop
  738.               i from 1 to (calendar-last-day-of-month month year) do
  739.             (mark-visible-calendar-date (list month i year)))
  740.         (mark-visible-calendar-date (list month p-day year)))))
  741.  
  742. (defun sort-diary-entries ()
  743.   "Sort the list of diary entries by time of day."
  744.   (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
  745.  
  746. (defun diary-entry-compare (e1 e2)
  747.   "Returns t if E1 is earlier than E2."
  748.   (or (calendar-date-compare e1 e2)
  749.       (and (calendar-date-equal (car e1) (car e2))
  750.            (< (diary-entry-time (car (cdr e1)))
  751.               (diary-entry-time (car (cdr e2)))))))
  752.  
  753. (defun diary-entry-time (s)
  754.   "Time at the beginning of the string S in a military-style integer.
  755. For example, returns 1325 for 1:25pm.  Returns -9999 if no time is recognized.
  756. The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
  757. and XX:XXam or XX:XXpm."
  758.   (cond ((string-match;; Military time  
  759.           "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
  760.          (+ (* 100 (string-to-int
  761.                     (substring s (match-beginning 1) (match-end 1))))
  762.             (string-to-int (substring s (match-beginning 2) (match-end 2)))))
  763.         ((string-match;; Hour only  XXam or XXpm
  764.           "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
  765.          (+ (* 100 (% (string-to-int
  766.                          (substring s (match-beginning 1) (match-end 1)))
  767.                         12))
  768.             (if (string-equal "a"
  769.                               (substring s (match-beginning 2) (match-end 2)))
  770.                 0 1200)))
  771.         ((string-match;; Hour and minute  XX:XXam or XX:XXpm
  772.           "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
  773.          (+ (* 100 (% (string-to-int
  774.                          (substring s (match-beginning 1) (match-end 1)))
  775.                         12))
  776.             (string-to-int (substring s (match-beginning 2) (match-end 2)))
  777.             (if (string-equal "a"
  778.                               (substring s (match-beginning 3) (match-end 3)))
  779.                 0 1200)))
  780.         (t -9999)));; Unrecognizable
  781.  
  782. (defun list-hebrew-diary-entries ()
  783.   "Add any Hebrew date entries from the diary-file to diary-entries-list.
  784. Hebrew date diary entries must be prefaced by a hebrew-diary-entry-symbol
  785. (normally an `H').  The same diary-date-forms govern the style of the Hebrew
  786. calendar entries, except that the Hebrew month names must be spelled in full.
  787. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  788. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  789. common Hebrew year.  If a Hebrew date diary entry begins with a
  790. diary-nonmarking-symbol the entry will appear in the diary listing, but will
  791. not be marked in the calendar.  This function is provided for use with the
  792. nongregorian-diary-listing-hook."
  793.   (if (< 0 number)
  794.       (let ((buffer-read-only nil)
  795.             (diary-modified (buffer-modified-p))
  796.             (gdate original-date)
  797.             (mark (regexp-quote diary-nonmarking-symbol)))
  798.         (calendar-for-loop i from 1 to number do
  799.            (let* ((d diary-date-forms)
  800.                   (hdate (calendar-hebrew-from-absolute 
  801.                           (calendar-absolute-from-gregorian gdate)))
  802.                   (month (extract-calendar-month hdate))
  803.                   (day (extract-calendar-day hdate))
  804.                   (year (extract-calendar-year hdate)))
  805.              (while d
  806.                (let*
  807.                    ((date-form (if (equal (car (car d)) 'backup)
  808.                                    (cdr (car d))
  809.                                  (car d)))
  810.                     (backup (equal (car (car d)) 'backup))
  811.                     (dayname
  812.                      (concat
  813.                       (calendar-day-name gdate) "\\|"
  814.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  815.                     (calendar-month-name-array
  816.                      calendar-hebrew-month-name-array-leap-year)
  817.                     (monthname
  818.                      (concat
  819.                       "\\*\\|"
  820.                       (calendar-month-name month)))
  821.                     (month (concat "\\*\\|0*" (int-to-string month)))
  822.                     (day (concat "\\*\\|0*" (int-to-string day)))
  823.                     (year
  824.                      (concat
  825.                       "\\*\\|0*" (int-to-string year)
  826.                       (if abbreviated-calendar-year
  827.                           (concat "\\|" (int-to-string (% year 100)))
  828.                         "")))
  829.                     (regexp
  830.                      (concat
  831.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  832.                       (regexp-quote hebrew-diary-entry-symbol)
  833.                       "\\("
  834.                       (mapconcat 'eval date-form "\\)\\(")
  835.                       "\\)"))
  836.                     (case-fold-search t))
  837.                  (goto-char (point-min))
  838.                  (while (re-search-forward regexp nil t)
  839.                    (if backup (re-search-backward "\\<" nil t))
  840.                    (if (and (or (char-equal (preceding-char) ?\^M)
  841.                                 (char-equal (preceding-char) ?\n))
  842.                             (not (looking-at " \\|\^I")))
  843.                        ;;  Diary entry that consists only of date.
  844.                        (backward-char 1)
  845.                      ;;  Found a nonempty diary entry--make it visible and
  846.                      ;;  add it to the list.
  847.                      (let ((entry-start (point))
  848.                            (date-start))
  849.                        (re-search-backward "\^M\\|\n\\|\\`")
  850.                        (setq date-start (point))
  851.                        (re-search-forward "\^M\\|\n" nil t 2)
  852.                        (while (looking-at " \\|\^I")
  853.                          (re-search-forward "\^M\\|\n" nil t))
  854.                        (backward-char 1)
  855.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  856.                        (add-to-diary-list
  857.                          gdate (buffer-substring entry-start (point)))))))
  858.                (setq d (cdr d))))
  859.            (setq gdate
  860.                  (calendar-gregorian-from-absolute
  861.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  862.            (set-buffer-modified-p diary-modified))
  863.         (goto-char (point-min))))
  864.  
  865. (defun mark-hebrew-diary-entries ()
  866.   "Mark days in the calendar window that have Hebrew date diary entries.
  867. Each entry in diary-file (or included files) visible in the calendar window
  868. is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
  869. (normally an `H').  The same diary-date-forms govern the style of the Hebrew
  870. calendar entries, except that the Hebrew month names must be spelled in full.
  871. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  872. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  873. common Hebrew year.  Hebrew date diary entries that begin with a
  874. diary-nonmarking symbol will not be marked in the calendar.  This function
  875. is provided for use as part of the nongregorian-diary-marking-hook."
  876.   (let ((d diary-date-forms))
  877.     (while d
  878.       (let*
  879.           ((date-form (if (equal (car (car d)) 'backup)
  880.                           (cdr (car d))
  881.                         (car d)));; ignore 'backup directive
  882.            (dayname (diary-name-pattern calendar-day-name-array))
  883.            (monthname
  884.             (concat
  885.              (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
  886.              "\\|\\*"))
  887.            (month "[0-9]+\\|\\*")
  888.            (day "[0-9]+\\|\\*")
  889.            (year "[0-9]+\\|\\*")
  890.            (l (length date-form))
  891.            (d-name-pos (- l (length (memq 'dayname date-form))))
  892.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  893.            (m-name-pos (- l (length (memq 'monthname date-form))))
  894.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  895.            (d-pos (- l (length (memq 'day date-form))))
  896.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  897.            (m-pos (- l (length (memq 'month date-form))))
  898.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  899.            (y-pos (- l (length (memq 'year date-form))))
  900.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  901.            (regexp
  902.             (concat
  903.              "\\(\\`\\|\^M\\|\n\\)"
  904.              (regexp-quote hebrew-diary-entry-symbol)
  905.              "\\("
  906.              (mapconcat 'eval date-form "\\)\\(")
  907.              "\\)"))
  908.            (case-fold-search t))
  909.         (goto-char (point-min))
  910.         (while (re-search-forward regexp nil t)
  911.           (let* ((dd-name
  912.                   (if d-name-pos
  913.                       (buffer-substring
  914.                        (match-beginning d-name-pos)
  915.                        (match-end d-name-pos))))
  916.                  (mm-name
  917.                   (if m-name-pos
  918.                       (buffer-substring
  919.                        (match-beginning m-name-pos)
  920.                        (match-end m-name-pos))))
  921.                  (mm (string-to-int
  922.                       (if m-pos
  923.                           (buffer-substring
  924.                            (match-beginning m-pos)
  925.                            (match-end m-pos))
  926.                         "")))
  927.                  (dd (string-to-int
  928.                       (if d-pos
  929.                           (buffer-substring
  930.                            (match-beginning d-pos)
  931.                            (match-end d-pos))
  932.                         "")))
  933.                  (y-str (if y-pos
  934.                             (buffer-substring
  935.                              (match-beginning y-pos)
  936.                              (match-end y-pos))))
  937.                  (yy (if (not y-str)
  938.                          0
  939.                        (if (and (= (length y-str) 2)
  940.                                 abbreviated-calendar-year)
  941.                            (let* ((current-y
  942.                                    (extract-calendar-year
  943.                                     (calendar-hebrew-from-absolute
  944.                                      (calendar-absolute-from-gregorian
  945.                                       (calendar-current-date)))))
  946.                                   (y (+ (string-to-int y-str)
  947.                                         (* 100 (/ current-y 100)))))
  948.                              (if (> (- y current-y) 50)
  949.                                  (- y 100)
  950.                                (if (> (- current-y y) 50)
  951.                                    (+ y 100)
  952.                                  y)))
  953.                          (string-to-int y-str)))))
  954.             (if dd-name
  955.                 (mark-calendar-days-named
  956.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  957.                              (calendar-make-alist
  958.                                calendar-day-name-array
  959.                                0
  960.                               '(lambda (x) (substring x 0 3))))))
  961.               (if mm-name
  962.                   (if (string-equal mm-name "*")
  963.                       (setq mm 0)
  964.                     (setq
  965.                       mm
  966.                       (cdr 
  967.                         (assoc
  968.                           (capitalize mm-name)
  969.                             (calendar-make-alist
  970.                                calendar-hebrew-month-name-array-leap-year))))))
  971.               (mark-hebrew-calendar-date-pattern mm dd yy)))))
  972.       (setq d (cdr d)))))
  973.  
  974. (defun mark-hebrew-calendar-date-pattern (month day year)
  975.   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
  976. A value of 0 in any position is a wild-card."
  977.   (save-excursion
  978.     (set-buffer calendar-buffer)
  979.     (if (and (/= 0 month) (/= 0 day))
  980.         (if (/= 0 year)
  981.             ;; Fully specified Hebrew date.
  982.             (let ((date (calendar-gregorian-from-absolute
  983.                          (calendar-absolute-from-hebrew
  984.                           (list month day year)))))
  985.               (if (calendar-date-is-visible-p date)
  986.                   (mark-visible-calendar-date date)))
  987.           ;; Month and day in any year--this taken from the holiday stuff.
  988.           (if (memq displayed-month;;  This test is only to speed things up a
  989.                     (list          ;;  bit; it works fine without the test too.
  990.                      (if (< 11 month) (- month 11) (+ month 1))
  991.                      (if (< 10 month) (- month 10) (+ month 2))
  992.                      (if (<  9 month) (- month  9) (+ month 3))
  993.                      (if (<  8 month) (- month  8) (+ month 4))
  994.                      (if (<  7 month) (- month  7) (+ month 5))))
  995.               (let ((m1 displayed-month)
  996.                     (y1 displayed-year)
  997.                     (m2 displayed-month)
  998.                     (y2 displayed-year)
  999.                     (year))
  1000.                 (increment-calendar-month m1 y1 -1)
  1001.                 (increment-calendar-month m2 y2 1)
  1002.                 (let* ((start-date (calendar-absolute-from-gregorian
  1003.                                     (list m1 1 y1)))
  1004.                        (end-date (calendar-absolute-from-gregorian
  1005.                                   (list m2
  1006.                                         (calendar-last-day-of-month m2 y2)
  1007.                                         y2)))
  1008.                        (hebrew-start
  1009.                         (calendar-hebrew-from-absolute start-date))
  1010.                        (hebrew-end (calendar-hebrew-from-absolute end-date))
  1011.                        (hebrew-y1 (extract-calendar-year hebrew-start))
  1012.                        (hebrew-y2 (extract-calendar-year hebrew-end)))
  1013.                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
  1014.                   (let ((date (calendar-gregorian-from-absolute
  1015.                                (calendar-absolute-from-hebrew
  1016.                                 (list month day year)))))
  1017.                     (if (calendar-date-is-visible-p date)
  1018.                         (mark-visible-calendar-date date)))))))
  1019.       ;; Not one of the simple cases--check all visible dates for match.
  1020.       ;; Actually, the following code takes care of ALL of the cases, but
  1021.       ;; it's much too slow to be used for the simple (common) cases.
  1022.       (let ((m displayed-month)
  1023.             (y displayed-year)
  1024.             (first-date)
  1025.             (last-date))
  1026.         (increment-calendar-month m y -1)
  1027.         (setq first-date
  1028.               (calendar-absolute-from-gregorian
  1029.                (list m 1 y)))
  1030.         (increment-calendar-month m y 2)
  1031.         (setq last-date
  1032.               (calendar-absolute-from-gregorian
  1033.                (list m (calendar-last-day-of-month m y) y)))
  1034.         (calendar-for-loop date from first-date to last-date do
  1035.           (let* ((h-date (calendar-hebrew-from-absolute date))
  1036.                  (h-month (extract-calendar-month h-date))
  1037.                  (h-day (extract-calendar-day h-date))
  1038.                  (h-year (extract-calendar-year h-date)))
  1039.             (and (or (zerop month)
  1040.                      (= month h-month))
  1041.                  (or (zerop day)
  1042.                      (= day h-day))
  1043.                  (or (zerop year)
  1044.                      (= year h-year))
  1045.                  (mark-visible-calendar-date
  1046.                   (calendar-gregorian-from-absolute date)))))))))
  1047.  
  1048. (defun list-sexp-diary-entries (date)
  1049.   "Add sexp entries for DATE from the diary-file to diary-entries-list.
  1050. Also, Make them visible in the diary file.  Returns t if any entries were
  1051. found.
  1052.  
  1053. Sexp diary entries must be prefaced by a sexp-diary-entry-symbol (normally
  1054. `%%').  The form of a sexp diary entry is
  1055.  
  1056.                   %%(SEXP) ENTRY
  1057.  
  1058. Both ENTRY and DATE are globally available when the SEXP is evaluated.  If the
  1059. SEXP yields the value nil, the diary entry does not apply.  If it yields a
  1060. non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
  1061. string, that string will be the diary entry in the fancy diary display.
  1062.  
  1063. For example, the following diary entry will apply to the 21st of the month
  1064. if it is a weekday and the Friday before if the 21st is on a weekend:
  1065.  
  1066.       &%%(let ((dayname (calendar-day-of-week date))
  1067.                (day (extract-calendar-day date)))
  1068.            (or
  1069.              (and (= day 21) (memq dayname '(1 2 3 4 5)))
  1070.              (and (memq day '(19 20)) (= dayname 5)))
  1071.          ) UIUC pay checks deposited
  1072.  
  1073. A number of built-in functions are available for this type of diary entry:
  1074.  
  1075.       %%(diary-float MONTH DAYNAME N) text
  1076.                   Entry will appear on the Nth DAYNAME of MONTH.
  1077.                   (DAYNAME=0 means Sunday, 1 means Monday, and so on;
  1078.                   if N is negative it counts backward from the end of
  1079.                   the month.  MONTH can be a list of months, a single
  1080.                   month, or t to specify all months.
  1081.  
  1082.       %%(diary-block M1 D1 Y1 M2 D2 Y2) text
  1083.                   Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
  1084.                   inclusive.  (If `european-calendar-style' is t, the
  1085.                   order of the parameters should be changed to D1, M1, Y1,
  1086.                   D2, M2, Y2.)
  1087.  
  1088.       %%(diary-anniversary MONTH DAY YEAR) text
  1089.                   Entry will appear on anniversary dates of MONTH DAY, YEAR.
  1090.                   (If `european-calendar-style' is t, the order of the
  1091.                   parameters should be changed to DAY, MONTH, YEAR.)  Text
  1092.                   can contain %d or %d%s; %d will be replaced by the number
  1093.                   of years since the MONTH DAY, YEAR and %s will be replaced
  1094.                   by the ordinal ending of that number (that is, `st', `nd',
  1095.                   `rd' or `th', as appropriate.  The anniversary of February
  1096.                   29 is considered to be March 1 in a non-leap year.
  1097.  
  1098.       %%(diary-cyclic N MONTH DAY YEAR) text
  1099.                   Entry will appear every N days, starting MONTH DAY, YEAR.
  1100.                   (If `european-calendar-style' is t, the order of the
  1101.                   parameters should be changed to N, DAY, MONTH, YEAR.)  Text
  1102.                   can contain %d or %d%s; %d will be replaced by the number
  1103.                   of repetitions since the MONTH DAY, YEAR and %s will
  1104.                   be replaced by the ordinal ending of that number (that is,
  1105.                   `st', `nd', `rd' or `th', as appropriate.
  1106.  
  1107.       %%(diary-day-of-year)
  1108.                   Diary entries giving the day of the year and the number of
  1109.                   days remaining in the year will be made every day.  Note
  1110.                   that since there is no text, it makes sense only if the
  1111.                   fancy diary display is used.
  1112.  
  1113.       %%(diary-iso-date)
  1114.                   Diary entries giving the corresponding ISO commercial date
  1115.                   will be made every day.  Note that since there is no text,
  1116.                   it makes sense only if the fancy diary display is used.
  1117.  
  1118.       %%(diary-french-date)
  1119.                   Diary entries giving the corresponding French Revolutionary
  1120.                   date will be made every day.  Note that since there is no
  1121.                   text, it makes sense only if the fancy diary display is used.
  1122.  
  1123.       %%(diary-islamic-date)
  1124.                   Diary entries giving the corresponding Islamic date will be
  1125.                   made every day.  Note that since there is no text, it
  1126.                   makes sense only if the fancy diary display is used.
  1127.  
  1128.       %%(diary-hebrew-date)
  1129.                   Diary entries giving the corresponding Hebrew date will be
  1130.                   made every day.  Note that since there is no text, it
  1131.                   makes sense only if the fancy diary display is used.
  1132.  
  1133.       %%(diary-astro-day-number) Diary entries giving the corresponding
  1134.                   astronomical (Julian) day number will be made every day.
  1135.                   Note that since there is no text, it makes sense only if the
  1136.                   fancy diary display is used.
  1137.  
  1138.       %%(diary-julian-date) Diary entries giving the corresponding
  1139.                  Julian date will be made every day.  Note that since
  1140.                  there is no text, it makes sense only if the fancy diary
  1141.                  display is used.
  1142.  
  1143.       %%(diary-sunrise-sunset)
  1144.                   Diary entries giving the local times of sunrise and sunset
  1145.                   will be made every day.  Note that since there is no text,
  1146.                   it makes sense only if the fancy diary display is used.
  1147.                   Floating point required.
  1148.  
  1149.       %%(diary-phases-of-moon)
  1150.                   Diary entries giving the times of the phases of the moon
  1151.                   will be when appropriate.  Note that since there is no text,
  1152.                   it makes sense only if the fancy diary display is used.
  1153.                   Floating point required.
  1154.  
  1155.       %%(diary-yahrzeit MONTH DAY YEAR) text
  1156.                   Text is assumed to be the name of the person; the date is
  1157.                   the date of death on the *civil* calendar.  The diary entry
  1158.                   will appear on the proper Hebrew-date anniversary and on the
  1159.                   day before.  (If `european-calendar-style' is t, the order
  1160.                   of the parameters should be changed to DAY, MONTH, YEAR.)
  1161.                   
  1162.       %%(diary-sunrise-sunset)
  1163.                   Diary entries giving the local times of Sabbath candle
  1164.                   lighting will be made every day.  Note that since there is
  1165.                   no text, it makes sense only if the fancy diary display is
  1166.                   used.  Floating point required.
  1167.  
  1168.       %%(diary-rosh-hodesh)
  1169.                   Diary entries will be made on the dates of Rosh Hodesh on
  1170.                   the Hebrew calendar.  Note that since there is no text, it
  1171.                   makes sense only if the fancy diary display is used.
  1172.  
  1173.       %%(diary-parasha)
  1174.                   Diary entries giving the weekly parasha will be made on
  1175.                   every Saturday.  Note that since there is no text, it
  1176.                   makes sense only if the fancy diary display is used.
  1177.  
  1178.       %%(diary-omer)
  1179.                   Diary entries giving the omer count will be made every day
  1180.                   from Passover to Shavuoth.  Note that since there is no text,
  1181.                   it makes sense only if the fancy diary display is used.
  1182.  
  1183. Marking these entries is *extremely* time consuming, so these entries are
  1184. best if they are nonmarking."
  1185.   (let* ((mark (regexp-quote diary-nonmarking-symbol))
  1186.          (sexp-mark (regexp-quote sexp-diary-entry-symbol))
  1187.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
  1188.          (entry-found))
  1189.     (goto-char (point-min))
  1190.     (while (re-search-forward s-entry nil t)
  1191.       (backward-char 1)
  1192.       (let ((sexp-start (point))
  1193.             (sexp)
  1194.             (entry)
  1195.             (entry-start)
  1196.             (line-start))
  1197.         (forward-sexp)
  1198.         (setq sexp (buffer-substring sexp-start (point)))
  1199.         (save-excursion
  1200.           (re-search-backward "\^M\\|\n\\|\\`")
  1201.           (setq line-start (point)))
  1202.         (forward-char 1)
  1203.         (if (and (or (char-equal (preceding-char) ?\^M)
  1204.                      (char-equal (preceding-char) ?\n))
  1205.                  (not (looking-at " \\|\^I")))
  1206.             (progn;; Diary entry consists only of the sexp
  1207.               (backward-char 1)
  1208.               (setq entry ""))
  1209.           (setq entry-start (point))
  1210.           (re-search-forward "\^M\\|\n" nil t)
  1211.           (while (looking-at " \\|\^I")
  1212.             (re-search-forward "\^M\\|\n" nil t))
  1213.           (backward-char 1)
  1214.           (setq entry (buffer-substring entry-start (point)))
  1215.           (while (string-match "[\^M]" entry)
  1216.             (aset entry (match-beginning 0) ?\n )))
  1217.         (let ((diary-entry (diary-sexp-entry sexp entry date)))
  1218.           (if diary-entry
  1219.               (subst-char-in-region line-start (point) ?\^M ?\n t))
  1220.           (add-to-diary-list date diary-entry)
  1221.           (setq entry-found (or entry-found diary-entry)))))
  1222.     entry-found))
  1223.  
  1224. (defun diary-sexp-entry (sexp entry date)
  1225.   "Process a SEXP diary ENTRY for DATE."
  1226.   (let ((result (if calendar-debug-sexp
  1227.                   (let ((stack-trace-on-error t))
  1228.                     (eval (car (read-from-string sexp))))
  1229.                   (condition-case nil
  1230.                       (eval (car (read-from-string sexp)))
  1231.                     (error
  1232.                      (beep)
  1233.                      (message "Bad sexp at line %d in %s: %s"
  1234.                               (save-excursion
  1235.                                 (save-restriction
  1236.                                   (narrow-to-region 1 (point))
  1237.                                   (goto-char (point-min))
  1238.                                   (let ((lines 1))
  1239.                                     (while (re-search-forward "\n\\|\^M" nil t)
  1240.                                       (setq lines (1+ lines)))
  1241.                                     lines)))
  1242.                               diary-file sexp)
  1243.                      (sleep-for 2))))))
  1244.     (if (stringp result)
  1245.         result
  1246.       (if result
  1247.           entry
  1248.         nil))))
  1249.  
  1250. (defun diary-block (m1 d1 y1 m2 d2 y2)
  1251.   "Block diary entry.
  1252. Entry applies if date is between two dates.  Order of the parameters is
  1253. M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
  1254. D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
  1255.   (let ((date1 (calendar-absolute-from-gregorian
  1256.                 (if european-calendar-style
  1257.                     (list d1 m1 y1)
  1258.                   (list m1 d1 y1))))
  1259.         (date2 (calendar-absolute-from-gregorian
  1260.                 (if european-calendar-style
  1261.                     (list d2 m2 y2)
  1262.                   (list m2 d2 y2))))
  1263.         (d (calendar-absolute-from-gregorian date)))
  1264.     (if (and (<= date1 d) (<= d date2))
  1265.         entry)))
  1266.  
  1267. (defun diary-float (month dayname n)
  1268.   "Floating diary entry--entry applies if date is the nth dayname of month.
  1269. Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
  1270. t, or an integer.  The constant t means all months.  If N is negative, count
  1271. backward from the end of the month."
  1272.   (let ((m (extract-calendar-month date))
  1273.         (y (extract-calendar-year date)))
  1274.     (if (and
  1275.          (or (and (listp month) (memq m month))
  1276.              (equal m month)
  1277.              (eq month t))
  1278.          (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
  1279.         entry)))
  1280.  
  1281. (defun diary-anniversary (month day year)
  1282.   "Anniversary diary entry.
  1283. Entry applies if date is the anniversary of MONTH, DAY, YEAR if
  1284. `european-calendar-style' is nil, and DAY, MONTH, YEAR if
  1285. `european-calendar-style' is t.  Diary entry can contain `%d' or `%d%s'; the
  1286. %d will be replaced by the number of years since the MONTH DAY, YEAR and the
  1287. %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
  1288. `rd' or `th', as appropriate.  The anniversary of February 29 is considered
  1289. to be March 1 in non-leap years."
  1290.   (let* ((d (if european-calendar-style
  1291.                 month
  1292.               day))
  1293.          (m (if european-calendar-style
  1294.                 day
  1295.               month))
  1296.          (y (extract-calendar-year date))
  1297.          (diff (- y year)))
  1298.     (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
  1299.         (setq m 3
  1300.               d 1))
  1301.     (if (and (> diff 0) (calendar-date-equal (list m d y) date))
  1302.         (format entry diff (diary-ordinal-suffix diff)))))
  1303.  
  1304. (defun diary-cyclic (n month day year)
  1305.   "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
  1306. If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
  1307. ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
  1308. years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
  1309. ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
  1310.   (let* ((d (if european-calendar-style
  1311.                 month
  1312.               day))
  1313.          (m (if european-calendar-style
  1314.                 day
  1315.               month))
  1316.          (diff (- (calendar-absolute-from-gregorian date)
  1317.                   (calendar-absolute-from-gregorian
  1318.                    (list m d year))))
  1319.          (cycle (/ diff n)))
  1320.     (if (and (>= diff 0) (zerop (% diff n)))
  1321.         (format entry cycle (diary-ordinal-suffix cycle)))))
  1322.  
  1323. (defun diary-ordinal-suffix (n)
  1324.   "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
  1325.   (if (or (memq (% n 100) '(11 12 13))
  1326.       (< 3 (% n 10)))
  1327.       "th"
  1328.     (aref ["th" "st" "nd" "rd"] (% n 10))))
  1329.  
  1330. (defun diary-day-of-year ()
  1331.   "Day of year and number of days remaining in the year of date diary entry."
  1332.   (let* ((year (extract-calendar-year date))
  1333.          (day (calendar-day-number date))
  1334.          (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
  1335.     (format "Day %d of %d; %d day%s remaining in the year"
  1336.              day year days-remaining (if (= days-remaining 1) "" "s"))))
  1337.  
  1338. (defun diary-iso-date ()
  1339.   "ISO calendar equivalent of date diary entry."
  1340.   (let ((day (% (calendar-absolute-from-gregorian date) 7))
  1341.         (iso-date (calendar-iso-from-absolute
  1342.                    (calendar-absolute-from-gregorian date))))
  1343.     (format "ISO date: Day %s of week %d of %d."
  1344.             (if (zerop day) 7 day)
  1345.             (extract-calendar-month iso-date)
  1346.             (extract-calendar-year iso-date))))
  1347.  
  1348. (defun diary-islamic-date ()
  1349.   "Islamic calendar equivalent of date diary entry."
  1350.   (let* ((i-date (calendar-islamic-from-absolute
  1351.                   (calendar-absolute-from-gregorian date)))
  1352.          (calendar-month-name-array calendar-islamic-month-name-array))
  1353.     (if (>= (extract-calendar-year i-date) 1)
  1354.         (format "Islamic date: %s" (calendar-date-string i-date nil t)))))
  1355.  
  1356. (defun diary-hebrew-date ()
  1357.   "Hebrew calendar equivalent of date diary entry."
  1358.   (let* ((h-date (calendar-hebrew-from-absolute
  1359.                   (calendar-absolute-from-gregorian date)))
  1360.          (calendar-month-name-array
  1361.           (if (hebrew-calendar-leap-year-p
  1362.                (extract-calendar-year h-date))
  1363.               calendar-hebrew-month-name-array-leap-year
  1364.             calendar-hebrew-month-name-array-common-year)))
  1365.     (format "Hebrew date: %s" (calendar-date-string h-date nil t))))
  1366.  
  1367. (defun diary-julian-date ()
  1368.   "Julian calendar equivalent of date diary entry."
  1369.   (format "Julian date: %s"
  1370.           (calendar-date-string
  1371.            (calendar-julian-from-absolute
  1372.             (calendar-absolute-from-gregorian date)))
  1373.           nil t))
  1374.  
  1375. (defun diary-astro-day-number ()
  1376.   "Astronomical (Julian) day number diary entry."
  1377.   (format "Astronomical (Julian) day number %d"
  1378.           (+ 1721425 (calendar-absolute-from-gregorian date))))
  1379.  
  1380. (defun diary-omer ()
  1381.   "Omer count diary entry.
  1382. Entry applies if date is within 50 days after Passover."
  1383.   (let* ((passover
  1384.           (calendar-absolute-from-hebrew
  1385.            (list 1 15 (+ (extract-calendar-year date) 3760))))
  1386.          (omer (- (calendar-absolute-from-gregorian date) passover))
  1387.          (week (/ omer 7))
  1388.          (day (% omer 7)))
  1389.     (if (and (> omer 0) (< omer 50))
  1390.         (format "Day %d%s of the omer (until sunset)"
  1391.                 omer
  1392.                 (if (zerop week)
  1393.                     ""
  1394.                   (format ", that is, %d week%s%s"
  1395.                           week
  1396.                           (if (= week 1) "" "s")
  1397.                           (if (zerop day)
  1398.                               ""
  1399.                             (format " and %d day%s"
  1400.                                     day (if (= day 1) "" "s")))))))))
  1401.  
  1402. (defun diary-yahrzeit (death-month death-day death-year)
  1403.   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
  1404. Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
  1405. to be the name of the person.  Date of death is on the *civil* calendar;
  1406. although the date of death is specified by the civil calendar, the proper
  1407. Hebrew calendar yahrzeit is determined.  If european-calendar-style is t, the
  1408. order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
  1409.   (let* ((h-date (calendar-hebrew-from-absolute
  1410.                   (calendar-absolute-from-gregorian
  1411.                    (if european-calendar-style
  1412.                        (list death-day death-month death-year)
  1413.                    (list death-month death-day death-year)))))
  1414.          (h-month (extract-calendar-month h-date))
  1415.          (h-day (extract-calendar-day h-date))
  1416.          (h-year (extract-calendar-year h-date))
  1417.          (d (calendar-absolute-from-gregorian date))
  1418.          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
  1419.          (diff (- yr h-year))
  1420.          (y (hebrew-calendar-yahrzeit h-date yr)))
  1421.     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
  1422.         (format "Yahrzeit of %s%s: %d%s anniversary"
  1423.                 entry
  1424.                 (if (= y d) "" " (evening)")
  1425.                 diff
  1426.                 (cond ((= (% diff 10) 1) "st")
  1427.                       ((= (% diff 10) 2) "nd")
  1428.                       ((= (% diff 10) 3) "rd")
  1429.                       (t "th"))))))
  1430.  
  1431. (defun diary-rosh-hodesh ()
  1432.   "Rosh Hodesh diary entry.
  1433. Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
  1434.   (let* ((d (calendar-absolute-from-gregorian date))
  1435.          (h-date (calendar-hebrew-from-absolute d))
  1436.          (h-month (extract-calendar-month h-date))
  1437.          (h-day (extract-calendar-day h-date))
  1438.          (h-year (extract-calendar-year h-date))
  1439.          (leap-year (hebrew-calendar-leap-year-p h-year))
  1440.          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
  1441.          (h-month-names
  1442.           (if leap-year
  1443.               calendar-hebrew-month-name-array-leap-year
  1444.             calendar-hebrew-month-name-array-common-year))
  1445.          (this-month (aref h-month-names (1- h-month)))
  1446.          (h-yesterday (extract-calendar-day
  1447.                        (calendar-hebrew-from-absolute (1- d)))))
  1448.     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
  1449.         (format
  1450.          "Rosh Hodesh %s"
  1451.          (if (= h-day 30)
  1452.              (format
  1453.               "%s (first day)"
  1454.               ;; next month must be in the same year since this
  1455.               ;; month can't be the last month of the year since
  1456.               ;; it has 30 days
  1457.               (aref h-month-names h-month))
  1458.            (if (= h-yesterday 30)
  1459.                (format "%s (second day)" this-month)
  1460.              this-month)))
  1461.       (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
  1462.           (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
  1463.                  (format "Mevarhim Rosh Hodesh %s (%s)"
  1464.                          (aref h-month-names
  1465.                                (if (= h-month
  1466.                                       (hebrew-calendar-last-month-of-year
  1467.                                        h-year))
  1468.                                    0 h-month))
  1469.                          (aref calendar-day-name-array (- 29 h-day))))
  1470.                 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
  1471.                  (format "Mevarhim Rosh Hodesh %s (%s-%s)"
  1472.                          (aref h-month-names h-month)
  1473.                          (if (= h-day 29)
  1474.                              "tomorrow"
  1475.                            (aref calendar-day-name-array (- 29 h-day)))
  1476.                          (aref calendar-day-name-array
  1477.                                (% (- 30 h-day) 7)))))
  1478.         (if (and (= h-day 29) (/= h-month 6))
  1479.             (format "Erev Rosh Hodesh %s"
  1480.                     (aref h-month-names
  1481.                           (if (= h-month
  1482.                                  (hebrew-calendar-last-month-of-year
  1483.                                   h-year))
  1484.                               0 h-month))))))))
  1485.  
  1486. (defun diary-parasha ()
  1487.   "Parasha diary entry--entry applies if date is a Saturday."
  1488.   (let ((d (calendar-absolute-from-gregorian date)))
  1489.     (if (= (% d 7) 6);;  Saturday
  1490.         (let*
  1491.             ((h-year (extract-calendar-year
  1492.                       (calendar-hebrew-from-absolute d)))
  1493.              (rosh-hashannah
  1494.               (calendar-absolute-from-hebrew (list 7 1 h-year)))
  1495.              (passover
  1496.               (calendar-absolute-from-hebrew (list 1 15 h-year)))
  1497.              (rosh-hashannah-day
  1498.               (aref calendar-day-name-array (% rosh-hashannah 7)))
  1499.              (passover-day
  1500.               (aref calendar-day-name-array (% passover 7)))
  1501.              (long-h (hebrew-calendar-long-heshvan-p h-year))
  1502.              (short-k (hebrew-calendar-short-kislev-p h-year))
  1503.              (type (cond ((and long-h (not short-k)) "complete")
  1504.                          ((and (not long-h) short-k) "incomplete")
  1505.                          (t "regular")))
  1506.              (year-format
  1507.               (symbol-value
  1508.                (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
  1509.                                rosh-hashannah-day type passover-day))))
  1510.              (first-saturday;; of Hebrew year
  1511.               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
  1512.              (saturday;; which Saturday of the Hebrew year
  1513.               (/ (- d first-saturday) 7))
  1514.              (parasha (aref year-format saturday)))
  1515.           (if parasha
  1516.               (format
  1517.                "Parashat %s"
  1518.                (if (listp parasha);; Israel differs from diaspora
  1519.                    (if (car parasha)
  1520.                        (format "%s (diaspora), %s (Israel)"
  1521.                                (hebrew-calendar-parasha-name (car parasha))
  1522.                                (hebrew-calendar-parasha-name (cdr parasha)))
  1523.                      (format "%s (Israel)"
  1524.                              (hebrew-calendar-parasha-name (cdr parasha))))
  1525.                  (hebrew-calendar-parasha-name parasha))))))))
  1526.  
  1527. (defun add-to-diary-list (date string)
  1528.   "Add the entry (DATE STRING) to the diary-entries-list.
  1529. Do nothing if DATE or STRING is nil."
  1530.   (and date string
  1531.        (setq diary-entries-list 
  1532.              (append diary-entries-list (list (list date string))))))
  1533.  
  1534. (defconst hebrew-calendar-parashiot-names
  1535. ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
  1536.  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
  1537.  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
  1538.  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
  1539.  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
  1540.  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
  1541.  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
  1542.  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
  1543.  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
  1544.   "The names of the parashiot in the Torah.")
  1545.  
  1546. ;; The seven ordinary year types (keviot)
  1547.  
  1548. (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
  1549.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1550.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1551.     43 44 45 46 47 48 49 50]
  1552.   "The structure of the parashiot.
  1553. Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
  1554. 29 days), and has Passover start on Sunday.")
  1555.  
  1556. (defconst hebrew-calendar-year-Saturday-complete-Tuesday
  1557.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1558.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1559.     43 44 45 46 47 48 49 [50 51]]
  1560.   "The structure of the parashiot.
  1561. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1562. have 30 days), and has Passover start on Tuesday.")
  1563.  
  1564. (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
  1565.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1566.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1567.     43 44 45 46 47 48 49 [50 51]]
  1568.   "The structure of the parashiot.
  1569. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1570. have 29 days), and has Passover start on Tuesday.")
  1571.  
  1572. (defconst hebrew-calendar-year-Monday-complete-Thursday
  1573.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1574.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1575.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1576.   "The structure of the parashiot.
  1577. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1578. 30 days), and has Passover start on Thursday.")
  1579.  
  1580. (defconst hebrew-calendar-year-Tuesday-regular-Thursday
  1581.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1582.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1583.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1584.   "The structure of the parashiot.
  1585. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1586. Kislev has 30 days), and has Passover start on Thursday.")
  1587.  
  1588. (defconst hebrew-calendar-year-Thursday-regular-Saturday
  1589.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
  1590.    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
  1591.    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
  1592.    49 50]
  1593.   "The structure of the parashiot.
  1594. Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
  1595. Kislev has 30 days), and has Passover start on Saturday.")
  1596.  
  1597. (defconst hebrew-calendar-year-Thursday-complete-Sunday
  1598.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1599.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1600.     43 44 45 46 47 48 49 50]
  1601.   "The structure of the parashiot.
  1602. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
  1603. have 30 days), and has Passover start on Sunday.")
  1604.  
  1605. ;; The seven leap year types (keviot)
  1606.  
  1607. (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
  1608.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1609.     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
  1610.     43 44 45 46 47 48 49 [50 51]]
  1611.   "The structure of the parashiot.
  1612. Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
  1613. have 29 days), and has Passover start on Tuesday.")
  1614.  
  1615. (defconst hebrew-calendar-year-Saturday-complete-Thursday
  1616.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1617.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1618.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1619.   "The structure of the parashiot.
  1620. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1621. have 30 days), and has Passover start on Thursday.")
  1622.  
  1623. (defconst hebrew-calendar-year-Monday-incomplete-Thursday
  1624.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1625.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1626.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1627.   "The structure of the parashiot.
  1628. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1629. have 29 days), and has Passover start on Thursday.")
  1630.  
  1631. (defconst hebrew-calendar-year-Monday-complete-Saturday
  1632.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1633.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1634.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1635.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1636.   "The structure of the parashiot.
  1637. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1638. 30 days), and has Passover start on Saturday.")
  1639.  
  1640. (defconst hebrew-calendar-year-Tuesday-regular-Saturday
  1641.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1642.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1643.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1644.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1645.   "The structure of the parashiot.
  1646. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1647. Kislev has 30 days), and has Passover start on Saturday.")
  1648.  
  1649. (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
  1650.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1651.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1652.     43 44 45 46 47 48 49 50]
  1653.   "The structure of the parashiot.
  1654. Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
  1655. have 29 days), and has Passover start on Sunday.")
  1656.  
  1657. (defconst hebrew-calendar-year-Thursday-complete-Tuesday
  1658.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1659.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1660.     43 44 45 46 47 48 49 [50 51]]
  1661.   "The structure of the parashiot.
  1662. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
  1663. have 30 days), and has Passover start on Tuesday.")
  1664.  
  1665. (defun hebrew-calendar-parasha-name (p)
  1666.   "Name(s) corresponding to parasha P."
  1667.   (if (arrayp p);; combined parasha
  1668.       (format "%s/%s"
  1669.               (aref hebrew-calendar-parashiot-names (aref p 0))
  1670.               (aref hebrew-calendar-parashiot-names (aref p 1)))
  1671.     (aref hebrew-calendar-parashiot-names p)))
  1672.  
  1673. (defun list-islamic-diary-entries ()
  1674.   "Add any Islamic date entries from the diary-file to diary-entries-list.
  1675. Islamic date diary entries must be prefaced by an islamic-diary-entry-symbol
  1676. (normally an `I').  The same diary-date-forms govern the style of the Islamic
  1677. calendar entries, except that the Islamic month names must be spelled in full.
  1678. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1679. Dhu al-Hijjah.  If an Islamic date diary entry begins with a
  1680. diary-nonmarking-symbol the entry will appear in the diary listing, but will
  1681. not be marked in the calendar.  This function is provided for use with the
  1682. nongregorian-diary-listing-hook."
  1683.   (if (< 0 number)
  1684.       (let ((buffer-read-only nil)
  1685.             (diary-modified (buffer-modified-p))
  1686.             (gdate original-date)
  1687.             (mark (regexp-quote diary-nonmarking-symbol)))
  1688.         (calendar-for-loop i from 1 to number do
  1689.            (let* ((d diary-date-forms)
  1690.                   (idate (calendar-islamic-from-absolute 
  1691.                           (calendar-absolute-from-gregorian gdate)))
  1692.                   (month (extract-calendar-month idate))
  1693.                   (day (extract-calendar-day idate))
  1694.                   (year (extract-calendar-year idate)))
  1695.              (while d
  1696.                (let*
  1697.                    ((date-form (if (equal (car (car d)) 'backup)
  1698.                                    (cdr (car d))
  1699.                                  (car d)))
  1700.                     (backup (equal (car (car d)) 'backup))
  1701.                     (dayname
  1702.                      (concat
  1703.                       (calendar-day-name gdate) "\\|"
  1704.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  1705.                     (calendar-month-name-array
  1706.                      calendar-islamic-month-name-array)
  1707.                     (monthname
  1708.                      (concat
  1709.                       "\\*\\|"
  1710.                       (calendar-month-name month)))
  1711.                     (month (concat "\\*\\|0*" (int-to-string month)))
  1712.                     (day (concat "\\*\\|0*" (int-to-string day)))
  1713.                     (year
  1714.                      (concat
  1715.                       "\\*\\|0*" (int-to-string year)
  1716.                       (if abbreviated-calendar-year
  1717.                           (concat "\\|" (int-to-string (% year 100)))
  1718.                         "")))
  1719.                     (regexp
  1720.                      (concat
  1721.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  1722.                       (regexp-quote islamic-diary-entry-symbol)
  1723.                       "\\("
  1724.                       (mapconcat 'eval date-form "\\)\\(")
  1725.                       "\\)"))
  1726.                     (case-fold-search t))
  1727.                  (goto-char (point-min))
  1728.                  (while (re-search-forward regexp nil t)
  1729.                    (if backup (re-search-backward "\\<" nil t))
  1730.                    (if (and (or (char-equal (preceding-char) ?\^M)
  1731.                                 (char-equal (preceding-char) ?\n))
  1732.                             (not (looking-at " \\|\^I")))
  1733.                        ;;  Diary entry that consists only of date.
  1734.                        (backward-char 1)
  1735.                      ;;  Found a nonempty diary entry--make it visible and
  1736.                      ;;  add it to the list.
  1737.                      (let ((entry-start (point))
  1738.                            (date-start))
  1739.                        (re-search-backward "\^M\\|\n\\|\\`")
  1740.                        (setq date-start (point))
  1741.                        (re-search-forward "\^M\\|\n" nil t 2)
  1742.                        (while (looking-at " \\|\^I")
  1743.                          (re-search-forward "\^M\\|\n" nil t))
  1744.                        (backward-char 1)
  1745.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  1746.                        (add-to-diary-list
  1747.                          gdate (buffer-substring entry-start (point)))))))
  1748.                (setq d (cdr d))))
  1749.            (setq gdate
  1750.                  (calendar-gregorian-from-absolute
  1751.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  1752.            (set-buffer-modified-p diary-modified))
  1753.         (goto-char (point-min))))
  1754.  
  1755. (defun mark-islamic-diary-entries ()
  1756.   "Mark days in the calendar window that have Islamic date diary entries.
  1757. Each entry in diary-file (or included files) visible in the calendar window
  1758. is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
  1759. (normally an `I').  The same diary-date-forms govern the style of the Islamic
  1760. calendar entries, except that the Islamic month names must be spelled in full.
  1761. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1762. Dhu al-Hijjah.  Islamic date diary entries that begin with a
  1763. diary-nonmarking-symbol will not be marked in the calendar.  This function is
  1764. provided for use as part of the nongregorian-diary-marking-hook."
  1765.   (let ((d diary-date-forms))
  1766.     (while d
  1767.       (let*
  1768.           ((date-form (if (equal (car (car d)) 'backup)
  1769.                           (cdr (car d))
  1770.                         (car d)));; ignore 'backup directive
  1771.            (dayname (diary-name-pattern calendar-day-name-array))
  1772.            (monthname
  1773.             (concat
  1774.              (diary-name-pattern calendar-islamic-month-name-array t)
  1775.              "\\|\\*"))
  1776.            (month "[0-9]+\\|\\*")
  1777.            (day "[0-9]+\\|\\*")
  1778.            (year "[0-9]+\\|\\*")
  1779.            (l (length date-form))
  1780.            (d-name-pos (- l (length (memq 'dayname date-form))))
  1781.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  1782.            (m-name-pos (- l (length (memq 'monthname date-form))))
  1783.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  1784.            (d-pos (- l (length (memq 'day date-form))))
  1785.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  1786.            (m-pos (- l (length (memq 'month date-form))))
  1787.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  1788.            (y-pos (- l (length (memq 'year date-form))))
  1789.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  1790.            (regexp
  1791.             (concat
  1792.              "\\(\\`\\|\^M\\|\n\\)"
  1793.              (regexp-quote islamic-diary-entry-symbol)
  1794.              "\\("
  1795.              (mapconcat 'eval date-form "\\)\\(")
  1796.              "\\)"))
  1797.            (case-fold-search t))
  1798.         (goto-char (point-min))
  1799.         (while (re-search-forward regexp nil t)
  1800.           (let* ((dd-name
  1801.                   (if d-name-pos
  1802.                       (buffer-substring
  1803.                        (match-beginning d-name-pos)
  1804.                        (match-end d-name-pos))))
  1805.                  (mm-name
  1806.                   (if m-name-pos
  1807.                       (buffer-substring
  1808.                        (match-beginning m-name-pos)
  1809.                        (match-end m-name-pos))))
  1810.                  (mm (string-to-int
  1811.                       (if m-pos
  1812.                           (buffer-substring
  1813.                            (match-beginning m-pos)
  1814.                            (match-end m-pos))
  1815.                         "")))
  1816.                  (dd (string-to-int
  1817.                       (if d-pos
  1818.                           (buffer-substring
  1819.                            (match-beginning d-pos)
  1820.                            (match-end d-pos))
  1821.                         "")))
  1822.                  (y-str (if y-pos
  1823.                             (buffer-substring
  1824.                              (match-beginning y-pos)
  1825.                              (match-end y-pos))))
  1826.                  (yy (if (not y-str)
  1827.                          0
  1828.                        (if (and (= (length y-str) 2)
  1829.                                 abbreviated-calendar-year)
  1830.                            (let* ((current-y
  1831.                                    (extract-calendar-year
  1832.                                     (calendar-islamic-from-absolute
  1833.                                      (calendar-absolute-from-gregorian
  1834.                                       (calendar-current-date)))))
  1835.                                   (y (+ (string-to-int y-str)
  1836.                                         (* 100 (/ current-y 100)))))
  1837.                              (if (> (- y current-y) 50)
  1838.                                  (- y 100)
  1839.                                (if (> (- current-y y) 50)
  1840.                                    (+ y 100)
  1841.                                  y)))
  1842.                          (string-to-int y-str)))))
  1843.             (if dd-name
  1844.                 (mark-calendar-days-named
  1845.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  1846.                              (calendar-make-alist
  1847.                                calendar-day-name-array
  1848.                                0
  1849.                                '(lambda (x) (substring x 0 3))))))
  1850.               (if mm-name
  1851.                   (if (string-equal mm-name "*")
  1852.                       (setq mm 0)
  1853.                     (setq mm
  1854.                           (cdr (assoc
  1855.                                 (capitalize mm-name)
  1856.                                 (calendar-make-alist
  1857.                                   calendar-islamic-month-name-array))))))
  1858.               (mark-islamic-calendar-date-pattern mm dd yy)))))
  1859.       (setq d (cdr d)))))
  1860.  
  1861. (defun mark-islamic-calendar-date-pattern (month day year)
  1862.   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
  1863. A value of 0 in any position is a wild-card."
  1864.   (save-excursion
  1865.     (set-buffer calendar-buffer)
  1866.     (if (and (/= 0 month) (/= 0 day))
  1867.         (if (/= 0 year)
  1868.             ;; Fully specified Islamic date.
  1869.             (let ((date (calendar-gregorian-from-absolute
  1870.                          (calendar-absolute-from-islamic
  1871.                           (list month day year)))))
  1872.               (if (calendar-date-is-visible-p date)
  1873.                   (mark-visible-calendar-date date)))
  1874.           ;; Month and day in any year--this taken from the holiday stuff.
  1875.           (let* ((islamic-date (calendar-islamic-from-absolute
  1876.                                 (calendar-absolute-from-gregorian
  1877.                                  (list displayed-month 15 displayed-year))))
  1878.                  (m (extract-calendar-month islamic-date))
  1879.                  (y (extract-calendar-year islamic-date))
  1880.                  (date))
  1881.             (if (< m 1)
  1882.                 nil;;   Islamic calendar doesn't apply.
  1883.               (increment-calendar-month m y (- 10 month))
  1884.               (if (> m 7);;  Islamic date might be visible
  1885.                   (let ((date (calendar-gregorian-from-absolute
  1886.                                (calendar-absolute-from-islamic
  1887.                                 (list month day y)))))
  1888.                     (if (calendar-date-is-visible-p date)
  1889.                         (mark-visible-calendar-date date)))))))
  1890.       ;; Not one of the simple cases--check all visible dates for match.
  1891.       ;; Actually, the following code takes care of ALL of the cases, but
  1892.       ;; it's much too slow to be used for the simple (common) cases.
  1893.       (let ((m displayed-month)
  1894.             (y displayed-year)
  1895.             (first-date)
  1896.             (last-date))
  1897.         (increment-calendar-month m y -1)
  1898.         (setq first-date
  1899.               (calendar-absolute-from-gregorian
  1900.                (list m 1 y)))
  1901.         (increment-calendar-month m y 2)
  1902.         (setq last-date
  1903.               (calendar-absolute-from-gregorian
  1904.                (list m (calendar-last-day-of-month m y) y)))
  1905.         (calendar-for-loop date from first-date to last-date do
  1906.           (let* ((i-date (calendar-islamic-from-absolute date))
  1907.                  (i-month (extract-calendar-month i-date))
  1908.                  (i-day (extract-calendar-day i-date))
  1909.                  (i-year (extract-calendar-year i-date)))
  1910.             (and (or (zerop month)
  1911.                      (= month i-month))
  1912.                  (or (zerop day)
  1913.                      (= day i-day))
  1914.                  (or (zerop year)
  1915.                      (= year i-year))
  1916.                  (mark-visible-calendar-date
  1917.                   (calendar-gregorian-from-absolute date)))))))))
  1918.  
  1919. (provide 'diary)
  1920.  
  1921. ;;; diary.el ends here
  1922.